Однородные полиномиальные уравнения

В.Э. Адлер. Классические интегрируемые системы, весенний семестр 2020

Здесь излагается метод неопределенных коэффициентов для отыскания высших симметрий и законов сохранения, в случае уравнений

(1)	(Subscript[u, t])=(Subscript[u, k])+P(u,(Subscript[u, 1]),...,(Subscript[u, k-1])),

где в правой части стоит многочлен, однородный относительно веса  w((Subscript[u, j]))=m+n j,  m,n>0.  Для поиска симметрии вида (Subscript[u, T])=(Subscript[u, K])+... генерируем многочлен с той же однородностью и неизвестными коэффициентами. Вычисляем коммутатор, собираем коэффициенты, решаем линейную систему. Точно так же ищутся законы сохранения.

Определим общие функции для символьных вычислений, которые нам потребуются (они уже обсуждались в программе 02_Inversion of the Miura transformation.nb)

(* список переменных u[_] в выражении f *)
vars[f_,u_]:=Union[Cases[f,_u,{0,∞}]]

(* df, дифференциал f *)
dif[f_]:=Plus@@(D[f,#]dd[#]&/@vars[f,u])

(* (Subscript[D, x])(f), (Subscript[D, x]^k)(f), полная производная по x от f *)
dx[f_]:=D[f,x]+dif[f]/.dd[u[k_]]:>u[k+1]
dx[f_,k_]:=Nest[dx,f,k]

(* (SubStar[g])(f), оператор линеаризации g, примененный к f *)
star[g_,f_]:=dif[g]/.dd[u[k_]]:>dx[f,k]

(* [f,g]=(SubStar[g])(f)-(SubStar[f])(g) *)
comm[f_,g_]:=Expand[star[g,f]-star[f,g]]

(* E(f), вариационная производная или оператор Эйлера *)
vard[f_]:=Expand[Plus@@((((-1))^(#[[1]]))dx[D[f,#],#[[1]]]&/@vars[f,u])]

(* порядок по производным *)
ord[f_]:=Module[{v=vars[f,u]},If[v=={},-1,v[[-1]][[1]]]]

(* интегрирование по частям *)
int[f_]:=Module[{a=0,b=Expand[f],c,k}, 
While[k=ord[b];     (* вычисляем k - порядок b *)
And[k>0,                   (* выполняем цикл, пока выполняется условие, что k>0 и *)
c=D[b,u[k]];     (* b линейна по старшей переменной *)
Expand[D[c,u[k]]]==0
],
c=Integrate[c,u[k-1]];   (* интегрируем по переменной, следующей по старшинству *)
a=Expand[a+c];                        (* пересчет a и b *)
b=Expand[b-dx[c]]
];
If[ord[b]==-1,    (* если в результате остаток не зависит от u, то это функция от х *)
{Expand[a+Integrate[b,x]],0},
{a,b}
]
]

Дополнительно заготовим несколько функций для генерации многочленов:

mon[d,r,k]  список мономов степени d от (Subscript[u, k]), (Subscript[u, k+1]),...  с общей суммой индексов равной r;

hom[m,n,M]  список всех мономов заданного веса M относительно веса w((Subscript[u, j]))=m+j n;

rhom[m,n,M]  то же самое, но без мономов, линейных по старшей переменной (следовательно, все мономы в этом списке неэквивалентны по модулю Im (Subscript[D, x]));

pol[l,c]  для заданного списка l длины n составляет линейную комбинацию  c[1]l[[1]]+...+c[n]l[[n]];

cfs[p,u]  список коэффициентов при всех мономах в многочлене p по переменным u. Повторяющиеся коэффициенты отбрасываются. Результат такой же, как от варианта с CoefficientList, но гораздо быстрее, если число переменных велико.

mon[d_,r_,k_]:=If[d==1,
If[r≥k,{u[r]},{}],
Flatten[Table[u[s]mon[d-1,r-s,s],{s,k,r}]]
]

hom[m_,n_,M_]:=Flatten[
Table[
If[IntegerQ[(M-m d)/n],mon[d,(M-m d)/n,0],{}],
{d,1,Floor[M/m]}]
]

rhom[m_,n_,M_]:=Select[hom[m,n,M],Exponent[#,Last[vars[#,u]]]>1||#==u[0]&]

pol[l_,c_]:=c/@Range[Length[l]].l

cfs[p_,u_]:=Module[{z,pp=Expand[p]},
If[FreeQ[pp,Plus],{pp/._u->1},
Union[
Reap[Map[Sow[z=#/._u->1,#/z]&,pp];,_,Plus@@#2&][[2]]
]]]

Тест. Сгенерируем длинный список, превратим его в многочлен, потом выпишем коэффициенты. Сделаем то же самое при помощи CoefficientList и сравним быстродействие.

hom[2,1,15];
Length[%]
A=pol[%%,c]

cfs[A,u]
Complement[Flatten[CoefficientList[A,vars[A,u]]],{0}]

Timing[Do[ClearSystemCache[];
cfs[A,u],
{k,1,50}]]

Timing[Do[ClearSystemCache[];
Complement[Flatten[CoefficientList[A,vars[A,u]]],{0}],
{k,1,50}]]

Определим функцию sym[ut,m,n,K], возвращающую, для заданной правой части (Subscript[u, t]), правую часть симметрии (Subscript[u, T])=(Subscript[u, K])+..., с однородностью w((Subscript[u, j]))=m+n j.  Однородность (Subscript[u, t]) не проверяется, хотя это несложно сделать.

Для поиска законов сохранения поступаем аналогично, но используем rhom вместо hom. Дифференцируем многочлен ρ по t, применяем оператор Эйлера, приравниваем нулю и решаем систему уравнений на коэффициенты (альтернативно, можно не применять оператор Эйлера, а решать систему (Subscript[D, t])(ρ)=(Subscript[D, x])(σ) в которой и ρ и σ – многочлены с неопределёнными коэффициентами).

sym[ut_,m_,n_,K_]:=Module[{uT,s,cc,c},
(* однородный многочлен с коэффициентами c[j] *)
uT=pol[hom[m,n,m+K n],c];
(* коэффициент при (Subscript[u, k]) делаем равным 1 *)
uT=uT/.Coefficient[uT,u[K]]->1; 
(* список неопределенных коэффициентов *)
cc=Complement[cfs[uT,u],{1}];  
(* вычисляем коммутатор, собираем коэффициенты, решаем систему уравнений на них *)
s=Solve[cfs[comm[uT,ut],u]==0,cc];
(* если решения нет, возвращаем 0 *) 
If[s=={},0,Expand[uT/.s[[1]]]] 
]

density[ut_,m_,n_,M_]:=Module[{rho,s,c},
rho=pol[rhom[m,n,M],c]/.c[1]->1;   
s=Solve[cfs[vard[star[rho,ut]],u]==0];
If[s=={},0,Expand[rho/.s[[1]]]]
]

В density мы полагаем коэффициент при старшем члене равным 1, чтобы решение определялось однозначно. В принципе, это может привести к потере ответа, если этот коэффициент на самом деле равен 0, но в тех примерах, что мы будем рассматривать, все оказывается в порядке.

Вычисление симметрий уравнения Бюргерса

Уравнение Бюргерса

(Subscript[u, t])=(Subscript[u, 2])+2u (Subscript[u, 1])

однородно относительно веса w((Subscript[u, j]))=1+j. У него есть высшие симметрии любого порядка. Зато, нет плотностей, кроме u (можно доказать, что уравнение порядка 2k не может иметь плотностей порядка выше k).

M=8;
Clear[ut]

Do[ut[k]=sym[u[2]+2u[0]u[1],1,1,k],{k,1,M}]

Для красоты выводим симметрии в индексной записи.

Do[Print[ut[j]/.u[n_]:>(Subscript[u, n])],{j,1,M}]

Проверим, что симметрии попарно коммутируют.

Table[comm[ut[i],ut[j]],{i,1,M-1},{j,i+1,M}]

Плотностей кроме u нет.

Table[density[ut[2],1,1,k],{k,1,5}]

Вычисление симметрий КдФ

Уравнение КдФ

(Subscript[u, t])=(Subscript[u, 3])+6u (Subscript[u, 1])

имеет вес w((Subscript[u, j]))=2+j. Вычисляем его симметрии до некоторого порядка.  Можно убедиться, что симметрий четного порядка нет.

M=15;
Clear[ut]

Timing[Do[ut[k]=sym[u[3]+6u[0]u[1],2,1,k],{k,1,M}]]

Do[Print[ut[j]/.u[n_]:>(Subscript[u, n])],{j,1,M}]

Проверим, что симметрии попарно коммутируют, ограничившись порядком 11.

Table[comm[ut[i],ut[j]],{i,1,9,2},{j,i+2,11,2}]

Вычисление плотностей для законов сохранения КдФ

Вот, для примера, все однородные мономы веса 22, неэквивалентные по модулю Im (Subscript[D, x])

rhom[2,1,22]
Length[%]

Именно до этого веса дошёл Миура-сэнсэй, только без компьютера, но не осилил; и тогда он придумал своё преобразование.

ut=u[3]+6u[0]u[1];
Do[rho[j]=density[ut,2,1,j],{j,4,22,2}]

(* проверка *)
Table[vard[star[rho[j],ut]],{j,4,22,2}]

(* вывод в индексной форме *)
Do[Print[rho[j]/.u[n_]:>(Subscript[u, n])],{j,4,22,2}]

Можно заметить, что полученные плотности не совпадают с теми, что получаются по рекуррентной схеме (см. программу 02_Inversion of the Miura transformation.nb), но это не удивительно, так как сейчас мы убрали все члены, эквивалентные по модулю Im (Subscript[D, x]).

Поиск новых примеров

До сих пор мы строили симметрии для наперёд заданного уравнения. Теперь попробуем искать одновременно уравнение и симметрию. Это резко усложняет задачу. Действительно, если уравнение задано, то определяющая система для неизвестных коэффициентов линейная. Если же и в самом уравнении коэффициенты неизвестны, то получается квадратичная система. Тем не менее, при не очень высоких порядках её удаётся решить и это даёт несколько любопытных уравнений 3-го и 5-го порядков, обладающих симметриями.

Сейчас мы воспроизведём эти примеры. Мы ограничимся весами w((Subscript[u, j]))=2+j  (такой же как у КдФ) и w((Subscript[u, j]))=1+2j. Имеются также несколько уравнений с весом w((Subscript[u, j]))=1+j, но они сводятся подстановками к уже найденным и мы пропустим этот случай. В других весах ответ оказывается пустым, это мы тоже не будем проверять. Также есть несколько полиномиальных уравнений, у которых коэффициент при старшей производной непостоянный, например, уравнение Дима (Subscript[u, t])=(u^3)(Subscript[u, 3]). Они тоже сводятся, более сложными заменами, к уже найденным.

Все эти примеры были найдены в конце 70-х. Оказывается, что кроме них других однородных полиномиальных иерархий с нет. Это было доказано сравнительно недавно. Задача классификации интегрируемых уравнений с правой частью общего вида не решена полностью даже для уравнений третьего порядка (Subscript[u, t])=f(x,u,(Subscript[u, 1]),(Subscript[u, 2]),(Subscript[u, 3])), не говоря о пятом.

. вес w((Subscript[u, j]))=2+j

В весе 5 имеется лишь два монома, так что кроме КдФ ответов нет.

Вес 6. Коэффициент при (Subscript[u, 4]) пусть равен 1. Функция sym теперь не годится. Формируем симметрию порядка 5, выписываем уравнения на коэффициенты и пытаемся их решить. Функция  GroebnerBasis помогает упростить систему, дальше применяем Solve. Нашелся только нулевой ответ, то есть линейные уравнения (Subscript[u, t])=(Subscript[u, 4]), (Subscript[u, T])=(Subscript[u, 5]), что не интересно.

hom[2,1,6]
ut=pol[%,a]/.a[1]->1
uT=pol[hom[2,1,7],b]/.b[1]->1

eqs=cfs[comm[uT,ut],u]
coef=Union[vars[ut,a],vars[uT,b]]

GroebnerBasis[eqs,coef]
sol=Solve[%==0]

Попробуем, для того же (Subscript[u, t]), взять симметрию порядка 6. Опять пусто.

uT=pol[hom[2,1,8],b]/.b[1]->1

eqs=cfs[comm[uT,ut],u];
coef=Union[vars[ut,a],vars[uT,b]];

GroebnerBasis[eqs,coef];
sol=Solve[%==0]

Вес 7. Коэффициент при (Subscript[u, 5]) пусть равен 1, а при u (Subscript[u, 3]) пусть равен 5 (этим мы исключаем линейное уравнение):

(Subscript[u, t])=(Subscript[u, 5])+5u (Subscript[u, 3])+...

Симметрию возьмем веса 9, (Subscript[u, τ])=(Subscript[u, 7])+....

hom[2,1,7];
ut=pol[%,a]/.{a[1]->1,a[2]->5}
uT=pol[hom[2,1,9],b]/.b[1]->1

eqs=cfs[comm[uT,ut],u];
coef=Union[vars[ut,a],vars[uT,b]];
eqs=GroebnerBasis[eqs,coef,MonomialOrder->DegreeReverseLexicographic]
sol=Union[Solve[eqs==0]]

Нашлось 3 ответа!

P1=ut/.sol[[1]]
P2=ut/.sol[[2]]
P3=ut/.sol[[3]]

Теперь для каждого из них можно искать симметрии при помощи старой функции sym. Оказывается, то один из ответов это симметрия уравнения порядка 3, то есть КдФ, с точностью до растяжения:

sym[P2,2,1,3]

Но два остальных это самостоятельные уравнения. Симметрий порядка 3 у них нет, а есть симметрии порядков 7,11,13,17,... Для них известны представления Лакса; оказывается, что они связаны с линейными уравнениями 3-го порядка (вместо уравнения Шрёдингера для КдФ).

Иерархия Савады-Котеры:

Do[Print[sym[P1,2,1,k]/.u[n_]:>(Subscript[u, n])],{k,1,13}]

Иерархия Каупа-Купершмидта:

Do[Print[sym[P3,2,1,k]/.u[n_]:>(Subscript[u, n])],{k,1,13}]

. вес w((Subscript[u, j]))=1+2j

Этот случай сложнее для анализа, так как здесь число мономов заданного веса значительно больше. Однако, ответ тут оказывается не такой интересный. Обнаруживается лишь одно новое уравнение, порядка 3, обладающее симметрией порядка 5 (в отличие от уравнений из предыдущего пункта, оно линеаризуемое, как и уравнение Бюргерса, хотя и более сложной подстановкой). Сразу перейдем к нему, пропуская другие случаи.

ut=pol[hom[1,2,7],a]/.{a[1]->1,a[2]->3}
uT=pol[hom[1,2,11],b]/.b[1]->1

eqs=cfs[comm[uT,ut],u];
coef=Union[vars[ut,a],vars[uT,b]];
eqs=GroebnerBasis[eqs,coef,MonomialOrder->DegreeReverseLexicographic];
sol=Union[Solve[eqs==0]]

Иерархия Ибрагимова-Шабата:

P=ut/.sol[[1]]
Do[Print[sym[P,1,2,k]/.u[n_]:>(Subscript[u, n])],{k,1,9}]